home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / printers / print-valdefs.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  5.3 KB  |  185 lines  |  [TEXT/CCL2]
  1. ;;; print-valdefs.scm -- print AST structures for local declarations
  2. ;;;
  3. ;;; author :  Sandra Loosemore
  4. ;;; date   :  14 Jan 1992
  5. ;;;
  6. ;;; This file corresponds to ast/valdef-structs.scm.
  7. ;;;
  8. ;;;
  9.  
  10.  
  11.  
  12. (define-ast-printer signdecl (object xp)
  13.   (with-ast-block (xp)
  14.     (write-delimited-list (signdecl-vars object) xp (function write) "," "" "")
  15.     (write-string " ::" xp)
  16.     (write-whitespace xp)
  17.     (write (signdecl-signature object) xp)))
  18.  
  19.  
  20. ;;; This interacts with the layout rule stuff.  See util.scm.
  21.  
  22. (define-ast-printer valdef (object xp)
  23.   (let ((lhs         (valdef-lhs object))
  24.     (definitions (filter (lambda (d)
  25.                    (not (single-fun-def-avoid-printing? d)))
  26.                  (valdef-definitions object))))
  27.     (write-definition lhs (car definitions) xp)
  28.     (dolist (d (cdr definitions))
  29.       (if (dynamic *print-pretty*)
  30.       (pprint-newline 'mandatory xp)
  31.       (write-string "; " xp))
  32.       (write-definition lhs d xp))))
  33.  
  34. (define-ast-printer single-fun-def (object xp)
  35.   (write-definition (**pat '| |) object xp))
  36.  
  37. (define (write-definition lhs d xp)
  38.   (with-ast-block (xp)
  39.     (let ((args        (single-fun-def-args d))
  40.       (rhs-list    (single-fun-def-rhs-list d))
  41.       (where-decls (single-fun-def-where-decls d))
  42.       (infix?      (single-fun-def-infix? d)))
  43.       (write-lhs lhs args infix? xp)
  44.       (write-rhs rhs-list xp)
  45.       (write-wheredecls where-decls xp)
  46.       )))
  47.                 
  48. (define (write-lhs lhs args infix? xp)       
  49.   (cond ((null? args)
  50.      ;; pattern definition
  51.      (write-apat lhs xp)
  52.      )
  53.         ;; If there are args, the lhs is always a var-pat pointing to a 
  54.         ;; var-ref. The infix? slot from the single-fun-def must override
  55.     ;; the slot on the var-ref, since there can be a mixture of
  56.     ;; infix and prefix definitions for the same lhs.
  57.     (infix?
  58.      ;; operator definition
  59.      (when (not (null? (cddr args)))
  60.        (write-char #\( xp))
  61.      (write-apat (car args) xp)
  62.      (write-whitespace xp)
  63.      (write-varop (var-ref-name (var-pat-var lhs)) xp)
  64.      (write-whitespace xp)
  65.      (write-apat (cadr args) xp)
  66.      (when (not (null? (cddr args)))
  67.        (write-char #\) xp)
  68.        (write-whitespace xp)
  69.        (write-delimited-list (cddr args) xp (function write-apat)
  70.                  "" "" "")))
  71.     (else
  72.      ;; normal prefix function definition
  73.      (write-varid (var-ref-name (var-pat-var lhs)) xp)
  74.      (write-whitespace xp)
  75.      (write-delimited-list args xp (function write-apat) "" "" ""))
  76.     ))
  77.  
  78. (define (write-rhs rhs-list xp)
  79.   (let ((guard   (guarded-rhs-guard (car rhs-list)))
  80.     (rhs     (guarded-rhs-rhs   (car rhs-list))))
  81.     (when (not (is-type? 'omitted-guard guard))
  82.       (write-string " | " xp)
  83.       (write guard xp))
  84.     (write-string " =" xp)
  85.     (write-whitespace xp)
  86.     (write rhs xp)
  87.     (when (not (null? (cdr rhs-list)))
  88.       (write-newline xp)
  89.       (write-rhs (cdr rhs-list) xp))))
  90.  
  91.  
  92. ;;; Pattern printers
  93.  
  94.  
  95. ;;; As per jcp suggestion, don't put whitespace after @; line break comes
  96. ;;; before, not after (as is the case for other infix-style punctuation).
  97.     
  98. (define-ast-printer as-pat (object xp)
  99.   (with-ast-block (xp)
  100.     (write (as-pat-var object) xp)
  101.     (write-whitespace xp)
  102.     (write-string "@" xp)
  103.     (write-apat (as-pat-pattern object) xp)))
  104.  
  105. (define (write-apat pat xp)
  106.   (if (or (is-type? 'apat pat)
  107.       (is-type? 'pp-pat-plus pat)  ; hack per jcp
  108.       (and (is-type? 'pcon pat)
  109.            (or (null? (pcon-pats pat))
  110.            (eq? (pcon-con pat) (core-symbol "UnitConstructor"))
  111.            (is-tuple-constructor? (pcon-con pat)))))
  112.       (write pat xp)
  113.       (begin
  114.         (write-char #\( xp)
  115.         (write pat xp)
  116.         (write-char #\) xp))))
  117.  
  118. (define-ast-printer irr-pat (object xp)
  119.   (write-string "~" xp)
  120.   (write-apat (irr-pat-pattern object) xp))
  121.  
  122. (define-ast-printer var-pat (object xp)
  123.   (write (var-pat-var object) xp))
  124.  
  125. (define-ast-printer wildcard-pat (object xp)
  126.   (declare (ignore object))
  127.   (write-char #\_ xp))
  128.  
  129. (define-ast-printer const-pat (object xp)
  130.   (write (const-pat-value object) xp))
  131.  
  132. (define-ast-printer plus-pat (object xp)
  133.   (write (plus-pat-pattern object) xp)
  134.   (write-string " + " xp)
  135.   (write (plus-pat-k object) xp))
  136.  
  137.  
  138.  
  139. (define-ast-printer pcon (object xp)
  140.   (let ((name    (pcon-name object))
  141.     (pats    (pcon-pats object))
  142.     (infix?  (pcon-infix? object))
  143.     (def     (pcon-con object)))
  144.     (cond ((eq? def (core-symbol "UnitConstructor"))
  145.        (write-string "()" xp))
  146.       ((is-tuple-constructor? def)
  147.        (write-commaized-list pats xp))
  148.           ((null? pats)
  149.        (if infix?
  150.            ;; infix pcon with no arguments can happen inside pp-pat-list
  151.            ;; before precedence parsing happens.
  152.            (write-conop name xp)
  153.            (write-conid name xp)))
  154.       (infix?
  155.        ;; This could be smarter about dealing with precedence of patterns.
  156.        (with-ast-block (xp)
  157.          (write-apat (car pats) xp)
  158.          (write-whitespace xp)
  159.          (write-conop name xp)
  160.          (write-whitespace xp)
  161.          (write-apat (cadr pats) xp)))
  162.       (else
  163.        (with-ast-block (xp)
  164.          (write-conid name xp)
  165.          (write-whitespace xp)
  166.          (write-delimited-list pats xp (function write-apat) "" "" "")))
  167.       )))
  168.  
  169. (define-ast-printer list-pat (object xp)
  170.   (write-delimited-list
  171.     (list-pat-pats object) xp (function write) "," "[" "]"))
  172.  
  173. (define-ast-printer pp-pat-list (object xp)
  174.   (write-delimited-list (pp-pat-list-pats object) xp (function write-apat)
  175.             "" "" ""))
  176.  
  177. (define-ast-printer pp-pat-plus (object xp)
  178.   (declare (ignore object))
  179.   (write-string "+ " xp))
  180.  
  181. (define-ast-printer pp-pat-negated (object xp)
  182.   (declare (ignore object))
  183.   (write-string "-" xp))
  184.  
  185.